MacFormat 1999 April/macformat-075.iso/Shareware Plus/Applications/Alpha/Tcl/SystemCode/textManip.tcl

Text File | 1999-01-28 | 29.9 KB | 1,095 lines | [TEXT/ALFA]

#===========================================================================
# Information about a selection or window.
#===========================================================================
proc wordCount {} {
    if {[set chars [string length [set text [getSelect]]]]} {
    set lines [expr {[lindex [posToRowCol [selEnd]] 0] - [lindex [posToRowCol [getPos]] 0]}]
    set text [getSelect]
    } else {
    set chars [maxPos]
    set lines [lindex [posToRowCol $chars] 0]
    set text [getText [minPos] [maxPos]]
    }
    regsub -all {[!=;.,\(\#\=\):\{\"\}]} $text " " text
    set words [llength $text]
    alertnote [format "%d chars, %d words, %d lines" $chars $words $lines]
}


# FILE: sortLines.tcl
#
# last update: 28/1/1999 {9:49:06 pm}
#
# This version of sortLines has the option of ignoring blanks/whitespace (-b)
# and case-insensitive sorting (-i), or reverse sorting:
#     sortLines [-b] [-i] [-r]

# COPYRIGHT:
#
#    Copyright © 1992,1993 by David C. Black All rights reserved.
#    Portions copyright © 1990, 1991, 1992 Pete Keleher. All Rights Reserved.
#
#    Redistribution and use in source and binary forms are permitted
#    provided that the above copyright notice and this paragraph are
#    duplicated in all such forms and that any documentation,
#    advertising materials, and other materials related to such
#    distribution and use acknowledge that the software was developed
#    by David C. Black.
#
#    THIS SOFTWARE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
#    IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
#    WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
################################################################################

# AUTHOR
#
#    David C. Black
#    GEnie:    D.C.Black
#    Internet: [e-mail] (preferred)
#    USnail:   6217 John Chisum Lane, Austin, TX 78749
#
################################################################################

proc reverseSort {} {sortLines -r}

proc sortLines {args} {
    set b_flag [lsearch $args "-b"]
    if {$b_flag != -1} {
    set args [lreplace $args $b_flag $b_flag]
    }
    incr b_flag

    set i_flag [lsearch $args "-i"]
    if {$i_flag != -1} {
    set args [lreplace $args $i_flag $i_flag]
    }
    incr i_flag

    if {[lsearch $args "-r"] >= 0} {
    set mode "-decreas"
    } else {
    set mode "-increas"
    }

    set start [getPos]
    set end  [selEnd]
    if {[pos::compare $start == $end]} {
    alertnote "You must highlight the section you wish to sort."
    return
    }
    if {[lookAt [pos::math $end - 1]] != "\r"} {
    alertnote "The selection must consist only of complete lines."
    return
    }
    set text [split [getText $start [pos::math $end - 1]] "\r"]
    if {$b_flag > 0 || $i_flag > 0} {
    foreach line $text {
        if {$i_flag > 0} {
        set key [string tolower $line]
        } else {
        set key $line
        }
        if {$b_flag > 0} {
        regsub -all "\[ \t\]+" $key " " key
        }
        set orig($key) $line
        lappend list $key
    }
    #endforeach
    unset text
    foreach key [lsort $mode $list] {
        lappend text $orig($key)
    }
    #endforeach
    } else {
    set text [lsort $mode $text]
    }
    set text [join $text "\r"]
    replaceText $start [pos::math $end - 1] $text
    select $start $end
}
# Test case:
#
# a  black
# a black cat
# A  black dog


##
 # -------------------------------------------------------------------------
 #
 # "sortParagraphs" --
 #
 #  Sorts selected paragraphs according to their first 30 characters,
 #  it's case insensitive and removes all non alpha-numeric characters
 #  before the sort.
 # -------------------------------------------------------------------------
 ##
proc sortParagraphs {args} {
    set start [getPos]
    set end  [selEnd]
    if {[pos::compare $start == $end]} {
    alertnote "You must highlight the section you wish to sort."
    return
    }
    if {[lookAt [pos::math $end - 1]] != "\r"} {
    alertnote "The selection must consist only of complete lines."
    return
    }
    set text [getText $start $end]
    if {[string first "•" $text] != -1} {
    alertnote "Sorry, can't sort paragraphs with bullets '•'."
    return
    }
    regsub -all "\[\r\n\]\[ \t\]*\[\r\n]" $text "\r•" text
    set paras [split $text "•"]
    unset text
    # now each paragraph ends in \r
    foreach para $paras {
    set key [string tolower [string range $para 0 30]]
    regsub -all {[^-a-z0-9]} $key "" key
    # so we don't clobber duplicates!
    while {[info exists orig($key)]} {append key "z"}
    set orig($key) $para
    }
    unset para
    foreach key [lsort [array names orig]] {
    lappend text $orig($key)
    }
    replaceText $start $end [join $text "\r"]
    select $start $end
}



#================================================================================
# Block shift left and right.
#================================================================================

proc shiftLeft {} {
    global shiftChar
    doShiftLeft $shiftChar
}

proc shiftLeftSpace {} {
    doShiftLeft " "
}

proc doShiftLeft {shiftChar} {
    set start [lineStart [getPos]]
    set end [nextLineStart [pos::math [selEnd] - 1]]
    if {[pos::compare $start >= $end]} {set end [nextLineStart $start]}

    set text [split [getText $start [pos::math $end - 1]] "\r\n"]

    set textout ""

    foreach line $text {
    if {[regexp ($shiftChar)(.*)$ $line "" "" c]} {
        lappend textout $c
    } else {
        lappend textout $line
    }
    }

    set text [join $textout "\r"]
    replaceText $start [pos::math $end - 1] $text
    select $start [pos::math $start + [expr {1 + [string length $text]}]]
}

proc shiftRight {} {
    global shiftChar
    doShiftRight $shiftChar
}

proc shiftRightSpace {} {
    doShiftRight " "
}

proc doShiftRight {shiftChar} {
    set start [lineStart [getPos]]
    set end [nextLineStart [pos::math [selEnd] - 1]]
    if {[pos::compare $start >= $end]} {set end [nextLineStart $start]}

    set text [split [getText $start [pos::math $end - 1]] "\r\n"]

    set textout ""

    foreach line $text {
    lappend textout $shiftChar$line
    }

    set text [join $textout "\r"]
    replaceText $start [pos::math $end - 1] $text
    select $start [pos::math $start + [expr {1 + [string length $text]}]]
}

proc selectAll {} {
    select [minPos] [maxPos]
}

# Select the next or current word. If word already selected, will go to next.
proc hiliteWord {} {
    if {[pos::compare [getPos] != [selEnd]]} forwardChar
    forwardWord
    set start [getPos]
    backwardWord
    select $start [getPos]
}

proc twiddle {} {
    set pos [getPos]
    if {[pos::compare $pos == [minPos]]} return
    if {[pos::compare $pos == [maxPos]] || \
      [pos::compare $pos == [pos::math [nextLineStart $pos] - 1]]} {
    set incr -1
    } else {
    set incr 0
    }
    if {[string length [set text [getSelect]]]} {
    if {[string length $text] == 1} {
        return
    } else {
        set sel [pos::math [selEnd] + $incr]
        set one [lookAt [pos::math $sel -1]]
        set two [lookAt $pos]
        replaceText $pos $sel "$one[getText [pos::math $pos + 1] [pos::math $sel - 1]]$two"
        select $pos $sel
        return
    }
    }
    set pos [pos::math $pos + $incr]
    set one [lookAt $pos]
    set two [lookAt [pos::math $pos - 1]]
    replaceText [pos::math $pos - 1] [pos::math $pos + 1] "$one$two"
    select  [pos::math $pos - 1] [pos::math $pos + 1]
}

proc twiddleWords {} {
    global wordBreakPreface wordBreak
    set pos [getPos]
    if {[pos::compare $pos == [maxPos]] || $pos == [pos::math [nextLineStart $pos] - 1]} {
    set eol 1
    } else {
    set eol 0
    }
    if {[pos::compare [getPos] != [selEnd]]} {
    set start1 [getPos]; set end2 [selEnd]
    select $start1
    forwardWord; set end1 [getPos]
    goto $end2
    backwardWord; set start2 [getPos]
    } else {
    if {$eol} {
        backwardWord; set pos [getPos]
    }
    select $pos
    backwardWord; set start1 [getPos]
    forwardWord; set end1 [getPos]
    goto $pos
    forwardWord; set end2 [getPos]
    backwardWord; set start2 [getPos]
    }

    if {$start1 != $start2} {
    set mid [getText $end1 $start2]
    replaceText $start1 $end2 "[getText $start2 $end2]$mid[getText $start1 $end1]"
    select $start1 $end2
    }
}

# proc commentLine {} {insertPrefix}
proc commentLine {} {
    global mode
    global ${mode}::commentCharacters
    if {![catch {commentCharacters Paragraph} chars]} {
    set start [lindex $chars 0]
    set end [lindex $chars 1]
    if {[string trim $start] == [string trim $end]} {
        insertPrefix
    } else {
        set ext  [file extension [win::CurrentTail]]
        if {($mode == "C" || $mode == "C++") && $ext != ".h" && $ext != ".c"} {
        insertPrefix
        } else {
        beginningOfLine
        insertText $start
        endOfLine
        insertText $end
        beginningOfLine
        }
    }
    } else {
    insertPrefix
    }
}

proc uncommentLine {} {removePrefix}
proc insertPrefix {} {doPrefix insert}
proc removePrefix {} {doPrefix remove}
proc doPrefix {which} {
    global prefixString
    if {[pos::compare [set start [getPos]] == [set end [selEnd]]]} {
    set end [nextLineStart $start]
    }
    set start [lineStart $start]
    set text [getText $start $end]
    replaceText $start $end [doPrefixText $which $prefixString $text]
    goto $start
    endOfLine
}

proc quoteChar {} {
    message "Literal keystroke to be inserted:"
    insertText [getChar]
}

proc setPrefix {} {
    global prefixString
    if {[catch {prompt "New Prefix String:" $prefixString} res] == 1} return
    set prefixString $res
}

proc setSuffix {} {
    global suffixString
    if {[catch {prompt "New Suffix String:" $suffixString} res] == 1} return
    set suffixString $res
}

proc insertSuffix {} {doSuffix insert}
proc removeSuffix {} {doSuffix remove}
proc doSuffix {which} {
    global suffixString
    set pts [getEndpts]
    set start [lindex $pts 0]
    set end [lindex $pts 1]
    set start [lineStart $start]
    set end [nextLineStart [pos::math $end - 1]]
    set text [getText $start $end]
    set text [doSuffixText $which $suffixString $text]
    replaceText $start $end $text
    select $start [getPos]
}

proc commentBox {} {

    # Preliminaries
    if {[commentGetRegion Box]} { return }

    set commentList [commentCharacters Box]
    if { [llength $commentList] == 0 } { return }

    set begComment [lindex $commentList 0]
    set begComLen [lindex $commentList 1]
    set endComment [lindex $commentList 2]
    set endComLen [lindex $commentList 3]
    set fillChar [lindex $commentList 4]
    set spaceOffset [lindex $commentList 5]

    set aSpace " "

    # First make sure we grab a full block of lines and adjust highlight

    set start [getPos]
    set start [lineStart $start]
    set end [selEnd]
    set end [nextLineStart [pos::math $end - 1]]
    select $start $end

    # Now get rid of any tabs

    if {[pos::compare $end < [maxPos]]} {
    createTMark stopComment [pos::math $end + 1]
    tabsToSpaces
    gotoTMark stopComment
    set end [pos::math [getPos] - 1]
    removeTMark stopComment
    } else {
    tabsToSpaces
    set end [maxPos]
    }
    select $start $end
    set text [getText $start $end]

# Next turn it into a list of lines--possibly drop an empty 'last line'

# VMD May'95: changed this code segment because it
# previously had problems with empty lines in the
# middle of the text to be commented

    set lineList [split $text "\r\n"]
    set ll [llength $lineList]
    if { [lindex $lineList end] == {} } {
    set lineList [lrange $lineList 0 [expr {$ll -2}] ]
    }
    set numLines [llength $lineList]

# end changes.

# Find the longest line length and determine the new line length

    set maxLength 0
    foreach thisLine $lineList {
    set thisLength [string length $thisLine]
    if { $thisLength > $maxLength } {
        set maxLength $thisLength
    }
    }
    set newLength [expr {$maxLength + 2 + 2*$spaceOffset}]

    # Now create the top & bottom bars and a blank line

    set topBar $begComment
    for { set i 0 } { $i < [expr {$newLength - $begComLen}] } { incr i } {
    append topBar $fillChar
    }
    set botBar ""
    for { set i 0 } { $i < [expr {$newLength - $endComLen}] } { incr i } {
    append botBar $fillChar
    }
    append botBar $endComment
    set blankLine $fillChar
    for { set i 0 } { $i < [expr {$newLength - 2}] } { incr i } {
    append blankLine " "
    }
    append blankLine $fillChar

    # For each line add stuff on left and spaces and stuff on right for box sides
    # and concatenate everything into 'text'.  Start with topBar; end with botBar

    set text $topBar\r$blankLine\r

    set frontStuff $fillChar
    set backStuff $fillChar
    for { set i 0 } { $i < $spaceOffset } { incr i } {
    append frontStuff " "
    set backStuff $aSpace$backStuff
    }
    set backStuffLen [string length $backStuff]

    for { set i 0 } { $i < $numLines } { incr i } {
    set thisLine [lindex $lineList $i ]
    set thisLine $frontStuff$thisLine
    set thisLength [string length $thisLine]
    set howMuchPad [expr {$newLength - $thisLength - $backStuffLen}]
    for { set j 0 } { $j < $howMuchPad } { incr j } {
        append thisLine " "
    }
    append thisLine $backStuff
    append text $thisLine \r
    }

    append text $blankLine \r $botBar \r

# Now replace the old stuff, turn spaces to tabs, and highlight

    replaceText    $start $end    $text
    set    end    [pos::math $start + [string length $text]]
    frontSpacesToTabs $start $end
}

proc uncommentBox {} {

# Preliminaries
    if {[commentGetRegion Box 1]} { return }

    set commentList [commentCharacters Box]
    if { [llength $commentList] == 0 } { return }

    set    begComment [lindex $commentList    0]
    set    begComLen [lindex $commentList 1]
    set    endComment [lindex $commentList    2]
    set    endComLen [lindex $commentList 3]
    set    fillChar [lindex $commentList 4]
    set    spaceOffset    [lindex    $commentList 5]

    set aSpace " "
    set aTab \t

    # First make sure we grab a full block of lines

    set start [getPos]
    set start [lineStart $start]
    set end [selEnd]
    set end [nextLineStart [pos::math $end - 1]]
    set text [getText $start $end]

    # Make sure we're at the start and end of the box

    set startOK [string first $begComment $text]
    set endOK [string last $endComment $text]
    set textLength [string length $text]
    if { $startOK != 0 || ($endOK != [expr {$textLength-$endComLen-1}] || $endOK == -1) } {
    alertnote "You must highlight the entire comment box, including the borders."
    return
    }

    # Now get rid of any tabs

    if {[pos::compare $end < [maxPos]] } {
    createTMark stopComment [pos::math $end + 1]
    tabsToSpaces
    gotoTMark stopComment
    set end [pos::math [getPos] - 1]
    removeTMark stopComment
    } else {
    tabsToSpaces
    set end [maxPos]
    }
    select $start $end
    set text [getText $start $end]

# Next turn it into a list of lines--possibly drop an empty 'last line'

# VMD May'95: changed this code segment because it
# previously had problems with empty lines in the
# middle of the text to be commented

    set lineList [split $text "\n\r"]
    set ll [llength $lineList]
    if { [lindex $lineList end] == {} } {
    set lineList [lrange $lineList 0 [expr {$ll -2}] ]
    }
    set numLines [llength $lineList]

# end changes.

# Delete the first and last lines, recompute number of lines

    set lineList [lreplace $lineList [expr {$numLines-1}] [expr {$numLines-1}] ]
    set lineList [lreplace $lineList 0 0 ]
    set numLines [llength $lineList]

    # Eliminate 2nd and 2nd-to-last lines if they are empty

    set eliminate $fillChar$aSpace$aTab
    set thisLine [lindex $lineList [expr {$numLines-1}]]
    set thisLine [string trim $thisLine $eliminate]
    if { [string length $thisLine] == 0 } {
    set lineList [lreplace $lineList [expr {$numLines-1}] [expr {$numLines-1}] ]
    }
    set thisLine [lindex $lineList 0]
    set thisLine [string trim $thisLine $eliminate]
    if { [string length $thisLine] == 0 } {
    set lineList [lreplace $lineList 0 0 ]
    }
    set numLines [llength $lineList]

# For each line trim stuff on left and spaces and stuff on right and splice

    set dropFromLeft [expr {$spaceOffset+1}]
    set text ""
    for { set i 0 } { $i < $numLines } { incr i } {
    set thisLine [lindex $lineList $i]
    set thisLine [string trimright $thisLine $eliminate]
    set thisLine [string range $thisLine $dropFromLeft end]
    set text $text$thisLine\r
    }

    # Now replace the old stuff, convert spaces back to tabs

    replaceText    $start $end    $text
    set end [pos::math $start + [string    length $text]]
    frontSpacesToTabs $start $end
}

##
 # -------------------------------------------------------------------------
 #
 # "commentCharacters" --
 #
 #    Adds the 'general' purpose characters which
 #    are    used to    check if we're in a    comment    block.
 #    Also has a check for an array entry like this:
 #
 #    set C++::commentCharacters(General) [list "*" "//"]
 #
 #    If such an entry exists, it is returned.  This allows mode authors
 #    to keep everything self-contained.
 # -------------------------------------------------------------------------
 ##
proc commentCharacters {purpose} {
    global mode commentCharacters
    global ${mode}::commentCharacters
    # allows a mode to define these things itself.
    if {[info exists ${mode}::commentCharacters(${purpose})]} {
    return [set ${mode}::commentCharacters(${purpose})]
    }
    if {[info exists commentCharacters(${mode}:${purpose})]} {
    return $commentCharacters(${mode}:${purpose})
    }
    switch -- $purpose {
    "General" {
        switch -- $mode {
        "TeX" {return "%" }
        "Text" {return "!" }
        "Fort" {return "C" }
        "Scil" {return "//" }
        "Perl" -
        "Tcl" {return "\#" }
        "C" {return "*" }
        "Java" -
        "C++" {return [list "*" "//"] }
        "HTML" {return "<!--"}
        default {
            return
        }
        }
    }
    "Paragraph" {
        switch -- $mode {
        "TeX" {return [list "%% " " %%" " % "] }
        "Text" {return [list "!! " " !!" " ! "] }
        "Fort" {return [list "CC " " CC" " C "] }
        "Scil" {return [list "//" "//" "//"] }
        "Perl" -
        "Tcl" {return [list "## " " ##" " # "] }
        "Java" -
        "C" -
        "C++" {return [list "/* " " */" " * "] }
        "HTML" { return [list "<!--" "-->" "|" ] }
        default {
            message "I don't know what comments should look like in this mode.  Sorry."
            error "No comment characters"
        }
        }
    }
    "Box" {
        switch -- $mode {
        "TeX" {return [list "%" 1 "%" 1 "%" 3] }
        "Text" {return [list "!" 1 "!" 1 "!" 3] }
        "Fort" {return [list "C" 1 "C" 1 "C" 3] }
        "Scil" {return [list "//" 2 "//"  2 "//" 3] }
        "Perl" -
        "Tcl" {return [list "#" 1 "#" 1 "#" 3] }
        "Java" -
        "C" -
        "C++" {return [list "/*" 2 "*/" 2 "*" 3] }
        "HTML" { return [list "<!--" 4 "-->" 3 "|" 3] }
        default {
            message "I don't know what comments should look like in this mode.  Sorry."
            error "No comment characters"
        }
        }
    }
    }

}

##
 # Default is to look for a    paragraph to comment out.
 # If sent '1',    then we    look for a commented region    to
 # uncomment.
 ##
proc commentGetRegion { purpose {uncomment 0 } } {
    if {[pos::compare [getPos] != [selEnd]]} {
    watchCursor
    return 0
    }

    # there's no selection, so we try and generate one

    set pos [getPos]
    if {$uncomment} {
    # uncommenting
    set commentList [commentCharacters $purpose]
    if { [llength $commentList] == 0 } { return 1}
    switch -- $purpose {
        "Box" {
        set begComment [lindex $commentList 0]
        set begComLen [lindex $commentList 1]
        set endComment [lindex $commentList 2]
        set endComLen [lindex $commentList 3]
        set fillChar [lindex $commentList 4]
        set spaceOffset [lindex $commentList 5]

        # get length of current line
        set line [getText [lineStart $pos] [nextLineStart $pos] ]
        set c [string trimleft $line]
        set slen [expr {[string length $line] - [string length $c]}]
        set start [string range $line 0 [expr {$slen -1 }] ]

        set pos [getPos]

        if { $start == "" } {
            set p $pos
            while { [string first $fillChar $line] == 0 && \
              [expr {[string last $fillChar $line] + [string length $fillChar]}] \
              >= [string length [string trimright $line]] } {
            set p [nextLineStart $p]
            set line [getText [lineStart $p] [nextLineStart $p]]
            }
            set end [lineStart $p]

            set p $pos
            set line "${fillChar}"
            while { [string first $fillChar $line] == 0 && \
              [expr {[string last $fillChar $line] + [string length $fillChar]}] \
              >= [string length [string trimright $line]] } {
            set p [prevLineStart $p]
            set line [getText [prevLineStart $p] [lineStart $p] ]
            }
            set begin [prevLineStart $p]

        } else {
            set line "$start"
            set p $pos
            while { [string range $line 0 [expr {$slen -1}] ] == "$start" } {
            set p [nextLineStart $p]
            set line [getText [lineStart $p] [nextLineStart $p]]
            }
            set end [prevLineStart $p]

            set p $pos
            set line "$start"
            while { [string range $line 0 [expr {$slen -1}] ] == "$start" } {
            set p [prevLineStart $p]
            set line [getText [prevLineStart $p] [lineStart $p] ]
            }
            set begin [lineStart $p]
        }

        set beginline [getText $begin [nextLineStart  $begin]]
        if { [string first "$begComment" "$beginline" ] != $slen } {
            message "First line failed"
            return 1
        }

        set endline [getText $end [nextLineStart $end]]
        set epos [string last "$endComment" "$endline"]
        incr epos [string length $endComment]
        set s [string range $endline $epos end ]
        set s [string trimright $s]

        if { $s != "" } {
            message "Last line failed"
            return 1
        }

        set end [nextLineStart $end]
        select $begin $end
        #alertnote "Sorry auto-box selection not yet implemented"
        }
        "Paragraph" {
        set begComment [lindex $commentList 0]
        set endComment [lindex $commentList 1]
        set fillChar [lindex $commentList 2]

        ##
         # basic idea is search    back and forwards for lines
         # that    don't begin    the    same way and then see if they
         # match the idea of the beginning and end of a    block
         ##

        set line [getText [lineStart $pos] [nextLineStart $pos] ]
        set chk [string range $line 0 [string first $fillChar $line]]
        if { [string trimleft $chk] != "" } {
            message "Not in a comment block"
            return 1
        }
        regsub -all {    } $line " " line
        set p [string first "$fillChar" "$line"]
        set start [string range "$line" 0 [expr {$p + [string length $fillChar] -1}]]
        set ll [commentGetFillLines $start]
        set begin [lindex $ll 0]
        set end [lindex $ll 1]

        set beginline [getText $begin [nextLineStart  $begin]]
        if {[string first "$begComment" "$beginline" ] != $p } {
            message "First line failed"
            return 1
        }

        set endline [getText $end [nextLineStart $end]]
        set epos [string last "$endComment" "$endline"]
        incr epos [string length $endComment]
        set s [string range $endline $epos end ]
        set s [string trimright $s]

        if { $s != "" } {
            message "Last line failed"
            return 1
        }
        #goto $end
        set end [nextLineStart $end]
        select $begin $end
        }
    }
    } else {
    # commenting out
    set searchString "^\[ \t\]*\$"
    set searchResult1 [search -s -f 0 -r 1 -n $searchString $pos]
    set searchResult2 [search -s -f 1 -r 1 -n $searchString $pos]
    if {[llength $searchResult1]} {
        set posStart [pos::math [lindex $searchResult1 1] + 1]
    } else {
        set posStart [minPos]
    }
    if {[llength $searchResult2]} {
        set posEnd [lindex $searchResult2 0]
    } else {
        set posEnd [pos::math [maxPos] + 1]
        goto [maxPos]
        insertText "\n"
    }
    select $posStart $posEnd
    }

    set str "Do you wish to "
    if {$uncomment} { append str "uncomment" } else { append str "comment out" }
    append str " this region?"
    return [expr {![dialog::yesno $str]}]
}


proc prevLineStart { pos } {
    return [lineStart [pos::math [lineStart $pos] - 1]]
}

proc commentSameStart { line start } {
    regsub -all "\t" "$line" " " line
    if { [string first "$start" "$line"] == 0 } {
    return 1
    } else {
    return 0
    }
}

proc commentGetFillLines { start } {
    set pos [getPos]
    regsub -all "\t" $start " " start
    set line "$start"

    set p $pos
    while { [commentSameStart "$line" "$start"] } {
    set p [nextLineStart $p]
    set line [getText [lineStart $p] [nextLineStart $p]]
    }
    set end [lineStart $p]

    set p $pos
    set line "$start"
    while { [commentSameStart "$line" "$start"] } {
    set p [prevLineStart $p]
    set line [getText [prevLineStart $p] [lineStart $p] ]
    }
    set begin [prevLineStart $p]
    return [list $begin $end]
}

##
 # Author: Vince Darley    <mailto:[e-mail]>
 ##

proc commentParagraph {} {

# Preliminaries
    if {[commentGetRegion Paragraph]} { return }

    set commentList [commentCharacters Paragraph]
    if { [llength $commentList] == 0 } { return }

    set begComment [lindex $commentList 0]
    set endComment [lindex $commentList 1]
    set fillChar [lindex $commentList 2]


    # First make sure we grab a full block of lines and adjust highlight

    set start [getPos]
    set start [lineStart $start]
    set end [selEnd]
    set end [nextLineStart [pos::math $end - 1]]
    select $start $end

    # Now get rid of any tabs

    if {[pos::compare $end < [maxPos]] } {
        createTMark stopComment [pos::math $end + 1]
        tabsToSpaces
        gotoTMark stopComment
        set end [pos::math [getPos] - 1]
        removeTMark stopComment
    } else {
        tabsToSpaces
        set end [maxPos]
    }
    select $start $end
    set text [getText $start $end]

# Next turn it into a list of lines--possibly drop an empty 'last line'

    set lineList [split $text "\r\n"]
    set ll [llength $lineList]
    if { [lindex $lineList end] == {} } {
        set lineList [lrange $lineList 0 [expr {$ll -2}] ]
    }
    set numLines [llength $lineList]

    # Find left margin for these lines
    set lmargin 100
    for { set i 0 } { $i < $numLines } { incr i } {
        set l [lindex $lineList $i]
        set lm [expr {[string length $l] - [string length [string trimleft $l]]}]
        if { $lm < $lmargin } { set lmargin $lm }
    }
    set ltext ""
    for { set i 0 } { $i < $lmargin } { incr i } {
        append ltext " "
    }

    # For each line add stuff on left and concatenate everything into 'text'.

    set text ${ltext}${begComment}\r

    for { set i 0 } { $i < $numLines } { incr i } {
        append text ${ltext} ${fillChar} [string range [lindex $lineList $i] $lmargin end] \r
    }
    append text ${ltext} ${endComment} \r

    # Now replace the old stuff, turn spaces to tabs, and highlight

    replaceText $start $end $text
    set end [pos::math $start + [string length $text]]
    frontSpacesToTabs $start $end
}

##
 # Author: Vince Darley    <[e-mail]>
 ##

proc uncommentParagraph {} {

    # Preliminaries
    if {[commentGetRegion Paragraph 1]} { return }

    set commentList [commentCharacters Paragraph]
    if { [llength $commentList] == 0 } { return }

    set begComment [lindex $commentList 0]
    set endComment [lindex $commentList 1]
    set fillChar [lindex $commentList 2]

    set aSpace " "
    set aTab \t

    # First make sure we grab a full block of lines and adjust highlight

    set start [getPos]
    set start [lineStart $start]
    set end [selEnd]
    set end [nextLineStart [pos::math $end - 1]]
    select $start $end
    set text [getText $start $end]

    # Find left margin for these lines
    set l [string range $text 0 [string first "\r" $text] ]
    set lmargin [expr {[string length $l] - [string length [string trimleft $l]]}]

    # Make sure we're at the start and end of the paragraph

    set startOK [string first $begComment $text]
    set endOK [string last $endComment $text]
    set textLength [string length $text]
    if { $startOK != $lmargin || ($endOK != [expr {$textLength-[string length $endComment]-1}] || $endOK == -1) } {
        alertnote "You must highlight the entire comment paragraph, including the tail ends."
        return
    }

    # Now get rid of any tabs

    if {[pos::compare $end < [maxPos]]} {
        createTMark stopComment [pos::math $end + 1]
        tabsToSpaces
        gotoTMark stopComment
        set end [pos::math [getPos] - 1]
        removeTMark stopComment
    } else {
        tabsToSpaces
        set end [maxPos]
    }
    select $start $end
    set text [getText $start $end]

    # Next turn it into a list of lines--possibly drop an empty 'last line'

    set lineList [split $text "\r\n"]
    set ll [llength $lineList]
    if { [lindex $lineList end] == {} } {
        set lineList [lrange $lineList 0 [expr {$ll -2}] ]
    }
    set numLines [llength $lineList]

    # Delete the first and last lines, recompute number of lines

    set lineList [lreplace $lineList [expr {$numLines-1}] [expr {$numLines-1}] ]
    set lineList [lreplace $lineList 0 0 ]
    set numLines [llength $lineList]

    # get the left margin
    set lmargin [string first $fillChar [lindex $lineList 0]]
    set ltext ""
    for { set i 0 } { $i < $lmargin } { incr i } {
        append ltext " "
    }

    # For each line trim stuff on left and spaces and stuff on right and splice
    set eliminate $fillChar$aSpace$aTab
    set dropFromLeft [expr {[string length $fillChar] + $lmargin}]
    set text ""
    for { set i 0 } { $i < $numLines } { incr i } {
        set thisLine [lindex $lineList $i]
        set thisLine [string trimright $thisLine $eliminate]
        set thisLine ${ltext}[string range $thisLine $dropFromLeft end]
        append text $thisLine \r
    }

    # Now replace the old stuff, turn spaces to tabs, and highlight


    replaceText    $start $end    $text
    set    end [pos::math $start + [string length $text]]
    frontSpacesToTabs $start $end
}


proc frontTabsToSpaces { start end } {
    select $start $end
    tabsToSpaces
}

proc frontSpacesToTabs { start end } {
    getWinInfo a
    set sp [string range "              " 1 $a(tabsize) ]
    set from [lindex [posToRowCol $start] 0]
    set to [lindex [posToRowCol $end] 0]
    while {$from <= $to} {
    set pos [rowColToPos $from 0]
    # get the leading whitespace of the current line
    set res [search -s -n -f 1 -r 1 "^\[ \t\]*" $pos]
    regsub -all "($sp| +\t)" [eval getText $res] "\t" front
    eval replaceText $res [list $front]
    incr from
    }
}

proc forwardDeleteUntil {{c ""}} {
    if {$c == ""} {
    message "Forward delete up to next:"
    set c [getChar]
    }
    set p [lindex [search -s -n -f 1 -r 1 [quote::Regfind $c] [getPos]] 0]
    if {$p != ""} {
    deleteText [getPos] [pos::math $p + 1]
    }
}

proc forwardDeleteWhitespace {} {
    set p [lindex [search -s -n -f 1 -r 1 {[^ \t\r\n]} [getPos]] 0]
    if {$p != ""} {
    deleteText [getPos] $p
    }
}